Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/glass/glass.lha/GLASS/tmpas/paslib.pt

Text File | 1990-10-02 | 13.6 KB | 618 lines

.. file: paslib.pt
..
.. Library of utility functions for the tm pascal code.

{ ---- start of ${tplfilename} ---- }

.if ${index tmgetc $(need_misc)}
{ Read a character from file 'f' in the global variable 'tmcurchar'.
  The eoln condition is automagically converted to a special
  'tmeolnchar' character.  During eof 'tmeofchar' is put
  into 'tmcurchar'.
}
procedure tmgetc( var f: text );
begin
    if eof( f ) then
    tmcurchar := tmeofchar
    else if eoln( f ) then begin
    readln( f );
    tmcurchar := tmeolnchar
    end
    else
    read( f, tmcurchar );
end; { tmgetc }

.endif
.if ${index tmreadc $(need_misc)}
{ Read a character from file 'f' without skipping
  preceding spaces. Handle octal and character backslash escapes.
}
procedure tmreadc( var f: text; var c: char );
var
    val: integer;
    digits : set of char;

begin
    digits := ['0'..'7'];
    if tmcurchar = '\' then begin
    tmgetc( f );
    if tmcurchar in ['b','f','n','r','t','v'] then begin
        case tmcurchar of
        'b': c := chr( 8 );
        'f': c := chr( 12 );
        'n': c := chr( 10 );
        'r': c := chr( 13 );
        't': c := chr( 9 );
        'v': c := chr( 11 );
        end;
        tmgetc( f )
    end
    else begin
        if tmcurchar in digits then begin
        val := ord( tmcurchar ) - ord( '0' );
        tmgetc( f );
        if tmcurchar in digits then begin
            val := val*8 + ord( tmcurchar ) - ord( '0' );
            tmgetc( f );
            if tmcurchar in digits then begin
            val := val*8 + ord( tmcurchar ) - ord( '0' );
            tmgetc( f );
            end
        end;
        c := chr( val );
        end
        else begin
        c := tmcurchar;
        tmgetc( f );
        end;
    end;
    end
    else begin
    c := tmcurchar;
    tmgetc( f );
    end;
end; { tmreadc }

.endif
.if ${index tmreadspc $(need_misc)}
{ Skip all space characters and Miranda style comment.
  For implementation reasons it is assumed that a single
  '|' starts comment instead of '||'.
  After the call 'tmcurchar' contains the next character.
}
procedure tmreadspc( var f: text );
var
    busy: boolean;
    spaceset: set of char;

begin
    spaceset := [' ', chr(9), chr(10), tmeolnchar, chr(11), chr(13)];
    busy := true;
    while busy do begin
    busy := false;
    if (tmcurchar in spaceset) then begin
        tmgetc( f );
        busy := true
    end;
    if (tmcurchar = '|') then begin
        repeat
        tmgetc( f );
        until tmcurchar in [tmeolnchar,tmeofchar];
        busy := true
    end;
    end;
end; { tmreadspc }

.endif
.if ${index tmneedc $(need_misc)}
{ Do 'tmreadspc' and try to character 'needc'. Write an
  error message and return true if this is not possible, else
  return false.
}
function tmneedc( var f, rf: text; needc: char ): boolean;
var
    err: boolean;

begin
    err := false;
    tmreadspc( f );
    if tmcurchar = tmeofchar then begin
    writeln( rf, 'Expected "', needc, '" but got EOF' );
    err := true
    end
    else if tmcurchar <> needc then begin
    writeln( rf, 'Expected "', needc, '" but got "', tmcurchar, '"' );
    err := true
    end
    else
    tmgetc( f );
    tmneedc := err
end; { tmneedc }

.endif
.if ${index tmreadobrac $(need_misc)}
{ Skip all space characters, and count the open brackets (`(')
  that you encounter up to the first other character. Set 'n'
  to the number of open brackets found.
}
procedure tmreadobrac( var f: text; var n: integer );
var
    done: boolean;

begin
    n := 0;
    done := false;
    repeat
    tmreadspc( f );
    if tmcurchar = '(' then begin
        tmgetc( f );
        n := n+1;
    end
    else
        done := true
    until done;
end; { tmreadobrac }

.endif
.if ${index tmreadcbrac $(need_misc)}
{ Skip all space characters, and try to read `n' close
  brackets. Give an error if this is not possible.
}
function tmreadcbrac( var f, rf:text; n: integer ): boolean;
var
    err: boolean;

begin
    err := false;
    while (n>0) and (not err) do begin
        err := tmneedc( f, rf, ')' );
    n := n-1
    end;
    tmreadcbrac := err
end;

.endif
.if ${index tmwritec $(need_misc)}
{ Write a character to file 'f'. Use an escape sequence if
  necessary }
procedure tmwritec( var f: text; c: char );
var
    ccode: integer;

    { Write the digits of an octal number 'n' to file 'f' }
    procedure writeoct( var f: text; n: integer );
    begin
    if( n<8 ) then begin
        write( f, chr( ord('0')+n ) );
    end
    else begin
        writeoct( f, n div 8 );
        write( f, chr( ord('0')+(n mod 8) ) );
    end;
    end; { writeoct }

begin
    ccode := ord( c );
    if ccode in [8, 12, 10, 13, 9, 11] then begin
    case ccode of
        8 : write( f, '\b' );
        12: write( f, '\f' );
        10: write( f, '\n' );
        13: write( f, '\r' );
        9 : write( f, '\t' );
        11: write( f, '\v' );
    end;
    end
    else if c in ['''', '"', '\'] then begin
    write( f, '\', c );
    end
    else if (ccode>=ord(' ')) and (ccode<=ord('~')) then begin
    write( f, c );
    end
    else begin
    write( f, '\' );
    writeoct( f, ccode );
    end;
end; { tmwritec }

.endif
.if ${index Readinteger $(need_misc)}
{ Read<type> function for Pascal type `integer' }
function Readinteger( var f, rf: text; var n: integer ): boolean;
var
    braccnt: integer;
    done: boolean;
    err: boolean;
    gotadig: boolean;
    neg: boolean;

begin
    n := 0;
    neg := false;
    err := false;
    tmreadobrac( f, braccnt );
    tmreadspc( f );
    if (tmcurchar in ['-','+']) then begin
    neg := (tmcurchar = '-');
    tmgetc( f )
    end;
    gotadig := false;
    repeat
    done := true;
    if (tmcurchar in ['0'..'9']) then begin
        n:=n*10 + (ord(tmcurchar)-ord('0'));
        tmgetc( f );
        done := false;
        gotadig := true
    end;
    until done;
    if not gotadig then begin
    write( rf, 'expected integer but got ' );
    if tmcurchar = tmeofchar then
        writeln( rf, 'EOF' )
    else
        writeln( rf, 'char with code ', ord( tmcurchar ):3 );
    err := true
    end;
    if neg then
    n := -n;
    if not err then err := tmreadcbrac( f, rf, braccnt );
    Readinteger := err;
end; { Readinteger }

.endif
.if ${index Writeinteger $(need_misc)}
{ Write an integer to file 'f'. Negative numbers are surrounded
  by () or else the Miranda parser will get angry. }
procedure Writeinteger( var f: text; n: integer );
begin
    if n>=0 then
    writeln( f, n:1 )
    else
    writeln( f, '(', n:1, ')' )
end; { Writeinteger }

.endif
.if ${index Cmpinteger $(need_misc)}
{ Compare two integers }
function Cmpinteger( a, b: integer ): integer;
begin
    Cmpinteger := a-b
end; { Cmpinteger }

.endif
.if ${index Rfreinteger $(need_misc)}
procedure Rfreinteger( var i: integer );
begin
    i := 0;
end;

.endif
.if ${index Copyinteger $(need_misc)}
function Copyinteger( i: integer ): integer;
begin
    Copyinteger := i;
end; { Copyinteger }

.endif
.if ${index Readreal $(need_misc)}
{ read<type> function for Pascal type `real' }
{ I STRONGLY disapprove of this method of converting a
  string of chars to a real number, because precision will be lost,
  but for the moment this is the best I can do in Pascal (CvR).
}
function Readreal( var f, rf: text; var r: real ): boolean;
var
    busy: boolean;
    done: boolean;
    gotadig: boolean;
    braccnt: integer;    { number of open brackets }
    err: boolean;
    stopit : boolean;    { true if number must have been completed }
    neg: boolean;    { mantissa sign }
    xneg: boolean;    { exponent sign }
    mantissa: real;    { mantissa }
    fracdiv: real;    { divisor for construction of fraction part }
    xp: integer;    { exponent }

    { calculate 10^n recursively. Assumes n>=0 }
    function pow10( n: integer ): real;
    var
    i: real;

    begin
    if n<1 then
        pow10 := 1
    else begin
        i := pow10( n div 2 );
        if odd( n ) then
        pow10 := 10 * i * i
        else
        pow10 := i * i
    end;
    end; { pow10 }

begin
    stopit := false;
    mantissa := 0;
    err := false;
    tmreadobrac( f, braccnt );
    tmreadspc( f );
    if tmcurchar = tmeofchar then begin
    writeln( rf, 'Expected integer but got EOF' );
    err := true;
    end;
    neg := false;
    if (not err) and (tmcurchar in ['-','+']) then begin
    neg := (tmcurchar = '-');
    tmgetc( f )
    end;
    if not err then begin
    busy := true;
    gotadig := false;
    while busy do begin
        busy := false;
        if (tmcurchar in ['0'..'9']) then begin
        mantissa:=mantissa*10 + (ord(tmcurchar)-ord('0'));
        tmgetc( f );
        busy := true;
        gotadig := true
        end;
    end;
    if not gotadig then begin
        write( rf, 'expected digits but got ' );
        if tmcurchar = tmeofchar then
        writeln( rf, 'EOF' )
        else
        writeln( rf, 'char with code ', ord( tmcurchar ):3 );
        err := true
    end;
    end;
    fracdiv := 0.1;
    if (not err) and (tmcurchar = '.') then begin
    tmgetc( f );
    done := false;
    repeat
        if tmcurchar in ['0'..'9'] then begin
        mantissa := mantissa + (ord(tmcurchar)-ord('0'))*fracdiv;
        tmgetc( f );
        fracdiv := fracdiv/10;
        end
        else
        done := true;
    until done;
    end;
    xp := 0;
    xneg := false;
    if (not err) and (tmcurchar in ['e', 'E']) then begin
    tmgetc( f );
    if (tmcurchar in ['-','+']) then begin
        xneg := (tmcurchar = '-');
        tmgetc( f )
    end;
    gotadig := false;
    repeat
        done := true;
        if (tmcurchar in ['0'..'9']) then begin
        xp:=xp*10 + (ord(tmcurchar)-ord('0'));
        tmgetc( f );
        done := false;
        gotadig := true
        end;
    until done;
    if not gotadig then begin
        write( rf, 'expected exponent but got ' );
        if tmcurchar = tmeofchar then
        writeln( rf, 'EOF' )
        else
        writeln( rf, 'char with code ', ord( tmcurchar ):3 );
        err := true
    end;
    end;
    if xneg then
    r := mantissa/pow10( xp )
    else
    r := mantissa * pow10( xp );
    if neg then
    r := -r;
    if not err then err := tmreadcbrac( f, rf, braccnt );
    Readreal := err
end; { Readreal }

.endif
.if ${index Writereal $(need_misc)}
{ Write a real to file 'f'. Negative numbers are surrounded
  by () or else the Miranda parser will get angry. }
procedure Writereal( var f: text; r: real );
begin
    if r>=0 then
    writeln( f, r )
    else
    writeln( f, '(', r, ')' )
end; { Writereal }

.endif
.if ${index Cmpreal $(need_misc)}
{ Compare two reals }
function Cmpreal( a, b: real ): integer;
begin
    if( a>b ) then
    Cmpreal := 1
    else if ( a<b ) then
    Cmpreal := -1
    else
    Cmpreal := 0;
end; { Cmpreal }

.endif
.if ${index Rfrereal $(need_misc)}
procedure Rfrereal( var i: real );
begin
    i := 0.0;
end;

.endif
.if ${index Copyreal $(need_misc)}
function Copyreal( i: real ): real;
begin
    Copyreal := i;
end; { Copyreal }

.endif
.if ${index Readboolean $(need_misc)}
{ Read a boolean from file 'f' into boolean 'b'.
  A boolean in represented by the constructors 'True' or
  'False' with the obvious interpretation.
}
function Readboolean( var f, rf: text; var b: boolean ): boolean;
const
    maxlen = 5;

type
    consnm = packed array [1..maxlen] of char;

var
    braccnt: integer;
    word: consnm;
    err: boolean;
    ix: integer;
    busy: boolean;
    alnumset: set of char;

begin
    b := false;
    alnumset := ['F', 'T', 'a', 'e', 'l', 'r', 's', 'u'];
    word := '     ';
    ix := 1;
    err := false;
    tmreadobrac( f, braccnt );
    tmreadspc( f );
    if not (tmcurchar in alnumset) then begin
    write( rf, 'expected boolean but got ' );
    if tmcurchar = tmeofchar then
        writeln( rf, 'EOF' )
    else
        writeln( rf, 'char with code ', ord( tmcurchar ):3 );
    err := true
    end;
    busy := true;
    while (not err) and busy and (tmcurchar in alnumset) do begin
    if ix>maxlen then begin
        writeln( rf, 'name too long for boolean: "', word, tmcurchar,'"' );
        err := true
    end
    else begin
        word[ix] := tmcurchar;
        tmgetc( f );
        ix := ix+1
    end;
    if not (tmcurchar in alnumset) then
        busy := false;
    end;
    if not err then begin
        if word = 'True ' then begin
                b := true
        end
        else if word = 'False' then begin
                b := false
        end
        else begin
            writeln( rf, 'bad constructor for boolean: "', word, '"' );
            err:=true
        end;
    end;
    if not err then err := tmreadcbrac( f, rf, braccnt );
    Readboolean := err;
end; { Readboolean }

.endif
.if ${index Writeboolean $(need_misc)}
{ Write a boolean to file 'f'. A boolean in represented by the
  constructors 'True' or 'False' with the obvious interpretation.
}
procedure Writeboolean( var f: text; b: boolean );
begin
    if b then
    write( f, 'True' )
    else
    write( f, 'False' );
end; { Writeboolean }

.endif
.if ${index Cmpboolean $(need_misc)}
{ Compare two booleans }
function Cmpboolean( a, b: boolean ): integer;
begin
    Cmpboolean := ord( a ) - ord( b )
end; { Cmpboolean }

.endif
.if ${index Rfreboolean $(need_misc)}
procedure Rfreboolean( var i: boolean );
begin
    i := false;
end;

.endif
.if ${index Copyboolean $(need_misc)}
function Copyboolean( i: boolean ): boolean;
begin
    Copyboolean := i;
end; { Copyboolean }

.endif
.if ${index Readchar $(need_misc)}
{ Read a char from file 'f' into char 'c'. }
function Readchar( var f, rf: text; var c: char ): boolean;
var
    braccnt: integer;
    err: boolean;

begin
    tmreadobrac( f, braccnt );
    err := tmneedc( f, rf, '''' );
    if not err then begin
    tmreadc( f, c );
    err := tmneedc( f, rf, '''' );
    end;
    if not err then err := tmreadcbrac( f, rf, braccnt );
    Readchar := err;
end; { Readchar }

.endif
.if ${index Writechar $(need_misc)}
{ Write a char to file 'f'. A char in represented by the
  constructors 'True' or 'False' with the obvious interpretation.
}
procedure Writechar( var f: text; c: char );
begin
    write( f, '''' );
    tmwritec( f, c );
    writeln( f, '''' );
end; { Writechar }

.endif
.if ${index Cmpchar $(need_misc)}
{ Compare two chars }
function Cmpchar( a, b: char ): integer;
begin
    Cmpchar := ord( a ) - ord( b )
end; { Cmpchar }

.endif
.if ${index Rfrechar $(need_misc)}
procedure Rfrechar( var i: char );
begin
    i := tmeofchar;
end;

.endif
.if ${index Copychar $(need_misc)}
function Copychar( i: char ): char;
begin
    Copychar := i;
end; { Copychar }

.endif
{ ---- end of ${tplfilename} ---- }